## fun.locator is from Mark Bravington's debug package (license GPL v2 or greater)
fun.locator <- function( fname, from=.GlobalEnv) {
  if( typeof( from)=='closure')
    from <- environment( from)
  else if( is.numeric( from)) 
    from <- ( if( from>0) sys.frame(from) else .GlobalEnv )

  is.here <- function( env) exists( fname, env=env, inherits=FALSE)
  orig.from <- from
  ff <- list()
  
  # First, look through any frame-stack definitions:
  search.envs <- lapply( 1:length( search()), pos.to.env) # stop when we get there
  while( !any( sapply( search.envs, identical, y=from))) {
    if( is.here( from))
      ff <- c( ff, from)
    from <- parent.env( from)
  }
  
  # Now the search list:
  ff <- c( ff, search.envs[ sapply( search.envs, is.here)])
  
  # Namespaces:
  ln <- lapply( loadedNamespaces(), asNamespace)
  ln <- ln[ !sapply( ln, identical, y=orig.from)] # could happen...
  ff <- c( ff, ln[ sapply( ln, is.here)]) 
  
  # Parents of namespaces (to catch imported versions of functions):
  ln.parents <- lapply( ln[-1], parent.env) # -1 removes the base namespace
  ff <- c( ff, ln.parents[ sapply( ln.parents, is.here)]) 
  
  # S3 methods:
  S3 <- lapply( ln, function( x) if( exists( '.__S3MethodsTable__.', x, inherits=FALSE)) get( '.__S3MethodsTable__.', x) else 0)
  S3 <- S3[ !sapply( S3, is.numeric)]
  ff <- c( ff, S3[ sapply( S3, is.here)])
  
  ff
}

## adapted from mtrace in Mark Bravington's debug package (license GPL v2 or greater)
assignAnywhere <- function(name, value, env = parent.frame(), inherits = TRUE) {
  rootName <- deparse(name)
##   if (!exists(rootName, env))
##     rootName <- rootObj(parse(text=name)[[1]])
   if (!exists(rootName, env))
     rootName <- rootObj(name)
  if (inherits)
    ff <- fun.locator(rootName, env)
  else
    ff <- list(env)
  for (this.ff in ff) { 
    locko <- bindingIsLocked(rootName, this.ff)
    if (locko)
      unlockBinding(rootName, this.ff)
#    assign(name, value, envir=this.ff, inherits = FALSE)
#    browser()
    eval(substitute(name <- value,
                    list(name = name, value = value)),
         env = this.ff)
    if (locko) {
      ow <- options('warn')
      on.exit(options(ow))
      options(warn=-1)
      lockBinding(rootName, this.ff)
    }
  }
}


makeConnector <- function(expr, connectionOrder = "after") {
##
## Returns a function that can in turn create a connection.
## A typical call is something like: 
##   connectAfter <- makeConnector({ origFun(...); newFun(...); })
##
## The function template is defined below. "substitute" is
## used to replace parts of the template.
## 
## Connections work by replacing a function with another function
## and using environments to store previous versions of functions.
## So, connectBefore(f1, f2) replaces f1 with function(...) {f2(...); f1(...)},
## and f1 is stored in the environment of the new function.
##
  expr <- substitute(expr)
  res <-
    evalq(substitute(
    function(fun, newFun, env = parent.frame(), ...,
             connectGlobally = !funExistsInEnv) {
      otherArgs <- list(...)
      funName <- deparse(substitute(fun))
      newFunName <- deparse(substitute(newFun))
      origFun <- fun
      funExistsInEnv <- exists(funName, env, inherits = FALSE) ||
                        exists(rootObj(substitute(fun)), env, inherits = FALSE)
#      browser()
      assignAnywhere(substitute(fun), env = env, inherits = connectGlobally,
                     value = structure(function(...) {
                       expr
                     }, class = connectionOrder, connectorName = newFunName,
                       source = NULL))
    }, list(expr = expr, # these are the substitutions
            connectionOrder = if (connectionOrder == "before") "beforeConnector" else "afterConnector")))
  mode(res) <- "function"
  environment(res) <- parent.frame()
  res
}

connectBefore <- function(fun, ...) UseMethod("connectBefore")
connectBefore.default <- makeConnector({ newFun(...); origFun(...) }, connectionOrder = "before")

connectAfter <- function(fun, ...) UseMethod("connectAfter")
connectAfter.default <- makeConnector({ origFun(...); newFun(...); })

connectAround <- function(fun, ...) UseMethod("connectAround")
connectAround.default <- makeConnector({ newFun(...); })

modifyResults <- function(fun, ...) UseMethod("modifyResults")
modifyResults.default <- makeConnector({ newFun(origFun(...)); })

#### This is what a typical connection function should look like. Now,
#### we use makeAdvice to fill in the templates.
##
## connectBefore <- function(fun, newFun, env = parent.frame(),
##                       inherits = !exists(funName, env, inherits = FALSE)) {
##   funName <- as.character(substitute(fun))
##   newFunName <- as.character(substitute(newFun))
##   if (is.character(fun))
##     fun <- get(fun, env = env)
##   origFun <- fun
##   assignAnywhere(funName, env = env, inherits = inherits,
##     value = structure(function(...) {
##       newFun(...)
##       origFun(...)
##     }, class = "beforeConnector", connectorName = newFunName))
## }

print.beforeConnector <- function(x, indent = "", ...) {
  print(unclass(x))
  if (!is.null(environment(x)) && exists("origFun", environment(x))) { 
    cat(indent, "newFun: \n", sep = "")
    cat(paste(indent, capture.output(print(get("newFun", environment(x)), indent = paste(".", indent))), collapse = "\n"), "\n")
    cat(indent, "origFun: \n", sep = "")
    cat(paste(indent, capture.output(print(get("origFun", environment(x)), indent = paste(".", indent))), collapse = "\n"), "\n")
  }
}

print.afterConnector <- function(x, indent = "", ...) {
  print(unclass(x))
  if (!is.null(environment(x)) && exists("origFun", environment(x))) { 
    cat(indent, "origFun: \n", sep = "")
    cat(paste(indent, capture.output(print(get("origFun", environment(x)), indent = paste(".", indent))), collapse = "\n"), "\n")
    cat(indent, "newFun: \n", sep = "")
    cat(paste(indent, capture.output(print(get("newFun", environment(x)), indent = paste(".", indent))), collapse = "\n"), "\n")
  }
}

##
## This removes Connections, either individually or all of them.
##
removeConnects <- function(fun, ...) UseMethod("removeConnects")
removeConnects.default <- function(fun, newFun = NULL, env = parent.frame(), ...,
                                   connectGlobally = !funExistsInEnv) {

  funName <- deparse(substitute(fun))
  newFunName <- deparse(substitute(newFun))
  funExistsInEnv <- exists(funName, env, inherits = FALSE) ||
                    exists(rootObj(substitute(fun)), env, inherits = FALSE)
  funSymbol <- substitute(fun)
  if (is.null(newFun)) {
    # drill down until we get to the original function:
    while (!is.null(environment(fun)) && exists("origFun", environment(fun))) 
      fun <- get("origFun", environment(fun))
    assignAnywhere(funSymbol, value = fun, env = env, inherits = connectGlobally)
  } else { # look for a specific advice to remove
    topFun <- fun
    lastenv <- env
    while (!is.null(environment(fun)) && exists("origFun", environment(fun)) &&
           newFunName != attr(fun, "connectorName")) {
      lastenv <- environment(fun)
      fun <- get("origFun", environment(fun))
    }
    if (newFunName == attr(fun, "connectorName") && exists("origFun", environment(fun))) {
      replaceFun <- get("origFun", env = environment(fun))
      if (identical(env, lastenv)) { # at the top level
        assignAnywhere(funSymbol, value = replaceFun, env = env, inherits = connectGlobally)
      } else {
        assign("origFun", value = replaceFun, env = lastenv)
#        assignAnywhere(funSymbol, value = topFun, env = env, inherits = connectGlobally)
      }
    }
  }
}

.runExamples <- function() {
  f1 = function(a,b) cat("F1 (A+B):", a+b, "\n")
  f2 = function(a,b) cat("F2 (A-B):", a-b, "\n")
  f3 = function(a,b) cat("F3 (A*B):", a*b, "\n")
  connectBefore(f1, f3)
  connectBefore(f1, f2)
  removeConnects(f1, f2)
  removeConnects(f1, f3)
  f1
  
  f1 = function(a,b) cat("F1 (A+B):", a+b, "\n")
  f2 = function(a,b) cat("F2 (A-B):", a-b, "\n")
  f3 = function(a,b) cat("F3 (A*B):", a*b, "\n")
  f1(5,3)
  connectBefore(f1, f2)
  f1(5,3)
  connectAfter(f1, f3)
  connectAfter(f1, function(a,b) cat("F4 (A/B):", a/b, "\n"))
  f1(5,3)
  f1
  removeConnects(f1, f2)
  removeConnects(f1, function(a,b) cat("F4 (A/B):", a/b, "\n"))
  f1(5,3)
  f1  # should be just f3 left connected
  
  p1 <- function(...) cat("plotting...\n")
  connectBefore(plot, function(...) cat("plotting...3\n"))
  connectBefore(plot, p1)
  plot(sin) 
  removeConnects(plot, p1)
  removeConnects(plot, function(...) cat("plotting...3\n"))
  plot(1:10)
  
  
  ## connectBefore("$",  
  ##   function(...) cat("accessing data frame..."))
  ## df = data.frame(a=1, b=2)
  ## df$a
  ## "$"(df, "a")
  ## removeConnects("$")
  
  df = data.frame(a=1, b=2)
  # note the backticks! it won't work with regular quotes
  connectBefore(`$<-.data.frame`, function(...) cat("DF"))
  #connectBefore(get("$<-.data.frame"), function(...) cat("DF"))
  df$c = 5
  removeConnects(`$<-.data.frame`)
  
  connectBefore(plot.default, function(...) cat("DF"))
  plot(1) 
  removeConnects(plot.default)
  plot(1)

  # try functions in list elements
  lst <- list(a = 1, b = function() cat("b"))
  connectBefore(lst$b, function() cat("a"))
  lst$b()
  removeConnects(lst$b)
  lst$b()

  # try it on environments
  e = new.env()
  with(e, {
    x <- 1
    ff <- function(x, y) x + y
  })
  connectBefore(e$ff, function(...) cat("p"))

  
  if (require(proto)) {
    b=function() cat("b")
    p = proto(expr = {
      x <- 1
      y <- 2
      ff <- function(.) cat("A")
      plot <- function(.) cat("hello")
    })
    p$x
    p$ff(1,2)
    connectBefore(`$.proto`, function(...) cat("Z"))
    p$x
    removeConnects(`$.proto`)
    p$x
    # this doesn't work:
    connectBefore(p$ff, function(...) cat("p"))
    # these do work:
    connectBefore(p[["ff"]], function(...) cat("B"))
    with(p, connectBefore(ff, function(...) cat("C")))
    #connectBefore(p$ff, function(...) cat("gg"))
    p$ff()
    p[["ff"]]
    with(p, connectBefore(plot, function(...) cat("ff")))
    p$plot()
  }


  
  ## Gabor had a neat trick to override mtext momentarily to allow
  ## plot.stl to have an adjustable x-axis label
  #library(proto) 
  #plot.stl <- function(..., xlab = "time") { 
  #        mtext <- function(text, ...) 
  #                graphics::mtext(if (text == "time") xlab else text, ...) 
  #        with( proto(plot.stl = stats:::plot.stl), plot.stl(...) ) 
  #} 
  #plot(stl(nottem, "per"), xlab = "X")
  
  # to do the same with aspects:
##   modifyArgs(mtext, function(text, ...) list(if (text == "time") "X" else text, ...))
##   plot(stl(nottem, "per"))
##   removeConnects(mtext)
  # Gabor's is still a better way to do this. Aspects do an across-the-board
  # modification, while Gabor's method only modifies mtext locally (safer).
  
  connectAround(median, mean) # replace the median with mean
  median(c(1:5, 50000)) 
  removeConnects(median)
  median(c(1:5, 50000))
  
  readData <- function(...) {
  }
  
  setUpModel <- function(...) {
  }
  
  analysisStep1 <- function(...) {
  }
  
  plotResults <- function(...) {
  }
  
  saveData <- function(...) {
  }
  
  readData()
  setUpModel()
  analysisStep1()
  plotResults()
  saveData()
  
  connectAfter(readData, setUpModel)
  connectAfter(setUpModel, analysisStep1)
  connectAfter(analysisStep1, saveData)
  connectAfter(analysisStep1, plotResults)
  
  a <- readData()
  a <- setUpModel(a)
  a <- analysisStep1(a)
  plotResults(a)
  saveData(a)
  
  modifyResults(readData, setUpModel)
  modifyResults(setUpModel, analysisStep1)
  modifyResults(analysisStep1, saveData)  # just make sure that saveData
                                          # returns a copy of the results of analysisStep1
  modifyResults(analysisStep1, plotResults)
  
  a$option1 <- TRUE
  a$N <- 1000
  setUpModel(a)
  ## -->
  ## plotResults( saveData( analysisStep1( setUpModel(a, option1 = TRUE, N = 1000) ) ) )
  
  connectAround(setUpModel, function(a, ...) analysisStep1(origFun(a, ...)))
  connectAround(analysisStep1, function(a, ...) {a <- origFun(a, ...); saveData(a); invisible(a)})
  connectAround(analysisStep1, function(a, ...) {a <- origFun(a, ...); plotResults(a); invisible(a)})
  
}

## this finds the root object, so rootObj(a$b@c) gives "a"
rootObj <- function(expr) {
  if (!is.language(expr))
    expr <- substitute(expr)
  if (length(expr) > 1)
    expr <- rootObj(expr[[2]])
  as.character(expr)
}

